(*
 *  MTASC - MotionTwin ActionScript2 Compiler
 *  Copyright (c)2004 Nicolas Cannasse
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)

open ActionScript
open Expr
open SwfTypes

(*
open ExtHashtbl
open ExtString
open ExtList
*)

open GenSwfJump
open GenSwfTools
open GenSwfGenerator
open GenSwfGeneratorTools

open Printf
open Extjava

let enable_main = ref false
let ftrace = ref None

(* TODO provide a java ext to handle utf8 *)
let to_utf8 str =
	try
		UTF8.validate str;
		str;
	with
		UTF8.Malformed_code -> 
			let b = UTF8.Buf.create 0 in
			String.iter (fun c -> UTF8.Buf.add_char b (UChar.of_char c)) str;
			UTF8.Buf.contents b

let use_components = ref false
let separate = ref true
let keep = ref false
let bgcolor = ref 0xFFFFFF
let frame = ref 1

let is_excluded (path,name) = false

let support_overlength_classes = ref true

let generate exprs =
	let ctx = {
		main = ref None;
		idents = newHashTable [emptyJNup];
		ops = (newList []);
		super_bindings = newHashTable [emptyJNup];
		current = Class.empty;
		code_pos = 1;
		ident_count = 0;
		stack = 0;
		reg_count = 0;
		locals = newHashTable [emptyJNup];
		stack_size = 0;
		cur_block = (EBreak,null_pos);
		breaks = [];
		forins = 0;
		continue_pos = 0;
		opt_push = false;
		curmethod = "";
	} in
        (* newAction here *)
	listAdd ctx.ops (JAction (newAction (AStringPool (newList []))));

	let tags = (newList []) in
	let hpackages = (newHashTable [emptyJNup]) in
	Class.generate (fun clctx ->
		ctx.current <- clctx;
		let ctx = (if !separate then new_context ctx else ctx) in
		if not (Class.intrinsic clctx) && not (is_excluded (Class.path clctx)) then begin
                        (* newAction here *)
			if !separate then listAdd ctx.ops  (JAction (newAction (AStringPool (newList []))));

			let ssize = actions_length ctx.ops in
			generate_class_code ftrace enable_main ctx clctx (if !separate then (newHashTable [emptyJNup]) else hpackages);

			if !separate then begin
                            let separateTag = newTagsObj ("__Packages." ^ s_type_path (Class.path clctx)) ctx.idents ctx.ops in
                            listAdd tags (JTagsObj separateTag);
                        end;

			let size = actions_length ctx.ops in
			if size - ssize >= 1 lsl 15 then
			begin
				if !support_overlength_classes then
					prerr_endline ("Warning: Class " ^ s_type_path (Class.path clctx) ^ " has 32 KiB or more of bytecode, which is not supported by older MTASC versions.")
				else
					failwith ("Error: Class " ^ s_type_path (Class.path clctx) ^ " has 32 KiB or more of bytecode; please refactor it or recompile without -32k-limit.");
				eliminate_overlength_jumps ctx.ops
				(* Note: It is possible here for the UInt16 parameters in (for example) function/try/catch/finally/with instructions to be overlength too.
				   However, we don't support dealing with that, since it should be way less common in real-world code than even overlength
				   classes, which are already very uncommon. For that same reason, we also don't bother to output nice error messages
				   in such a case; the user will just see an Overflow exception from IO.write_ui16. If we ever do want to check for overlength
				   UInt16's, though, this would be the spot to do it. *)
			end;
		end;	
	) exprs;

	if not !separate then begin
            let tagObj = newTagsObj "__Packages.MTASC" ctx.idents ctx.ops in
            listInsert tags 0 (JTagsObj tagObj);
        end;
        listRev tags;

        (* to be used later, to replace List.map *)

        let createListOfUTF8Ids aList =
            let aResList = (newList []) in
            for y = 0 to (listLength aList) do
                listAdd aResList (JString (asString(getMField (listGet tags y) "id")));
            done;
            aResList
        in
        for i = 0 to listLength tags do
            let curItem = listGet tags i in
            let idents = asHashTable (getMField curItem "idents") in
            let ops = asDynArray (getMField curItem "ops") in
            let idents = hashTableFold (fun ident pos acc -> (ident,pos) :: acc) idents [] in
            let idents = hashTableSort (fun (_,p1) (_,p2) -> compare p1 p2) idents in
            (* newAction here *)
            listSet ops 0 (JAction (newAction (AStringPool (createListOfUTF8Ids idents))));
        done;

	let found = ref false in
	let curf = ref !frame in
	let regs = (newList []) in
	let found_ids = (newList []) in
	let insert loop showf acc l =
		if !found || !curf > 1 then begin
			curf := !curf - 1;
			loop (listConcat showf acc) l
		end else begin
			found := true;
			let main = ref None in
			let rec loop_tag cid l =
                                if (listExists found_ids (JInt cid)) then
                                    loop_tag (cid + 1) l
                                else
                                    loop_tag_rec cid l
			and loop_tag_rec cid l =
                            match (listLength l) with
                                | 0 -> (newList [])
                                | _ ->
                                    let firstElt = (listGet l 0) in
                                    let name = asString (getMField firstElt "name") in
                                    let ops = asDynArray (getMField firstElt "ops") in
                                    match name with
                                        | "" ->
                                            main := Some (JTagObj (newTag 0 true (TDoAction ops)));
                                            loop_tag (cid + 1) l
                                        | _ ->
                                            let tagRecFunc tagList exportList =
                                                listAdd tagList (JTagObj (newTag cid true (TClip (newClip cid 1 []))));
                                                listAdd exportList (JExport (newExport cid name));
                                                listAdd tagList (JTagObj (newTag cid true (TExports exportList)));
                                                listAdd tagList (JTagObj (newTag cid true (TDoInitAction (newDoInitAction cid ops))));
                                                listAdd tagList (JTagObj (loop_tag (cid + 1) l));
                                                tagList
                                            in
                                            let returnList = tagRecFunc (newList []) (newList []) in
                                            returnList
			in
                        let revOneList oneList =
                            listRev oneList;
                            oneList
                        in
                        let tList = revOneList (loop_tag 0x5000 tags) in
                        let mainList =
                            match !main with
                                | None -> (newList [])
                                | Some m ->
                                    let processMainList aList =
                                        listAdd aList m;
                                        aList
                                    in
                                    processMainList (newList [])
                        in
                        let loopList = listConcat showf mainList in
                        let loopList = listConcat loopList regs in
                        let loopList = listConcat loopList tList in
                        let loopList = listConcat loopList acc in
			loop loopList l
                end
	in
	let replace_package p cid x y z =
		if p = "__Packages.MTASC" || (not !use_components && not !keep) then
			(newList [])
		else 
                    let addInList aList x y z =
                        listAdd aList x;
                        listAdd aList y;
                        listAdd aList z;
                    in
                    let replacePackageFunc returnList =
                        for i = 0 to listLength tags do
                            let curItem = listGet tags i in
                            let n = asString (getMField curItem "n") in
                            if p = n then
                            begin
                                listRemove tags i;
                                let z = newTag cid true (TDoInitAction (newDoInitAction cid (asActions (getMField curItem "o"))))
                                in
                                addInList returnList x y (JTagObj z);
                            end
                            else begin
                                if !keep || (!use_components && String.length p > 14 && String.sub p 0 14 = "__Packages.mx.") then
                                    addInList returnList x y z;
                            end
                        done;
                        returnList
                    in
                    let resList = replacePackageFunc (newList []) in
                    resList
	in
	let rec loop acc aList =
            match (listLength aList) with
		| 0 ->
                    if not !found then
                        failwith ("Frame " ^ string_of_int !frame ^ " not found in SWF");
                    listRev acc
                | _ as n ->
                    let retrieveItemAndDataFromIndex idx =
                        if n >= idx+1 then
                        (
                            let item = (listGet aList idx) in
                            let data = getMField item "tdata" in
                            item,data
                        )
                        else
                            (* might involves some issues with the recursion *)
                            JVoid,JVoid
                    in
                    let x,xdata = retrieveItemAndDataFromIndex 0 in
                    let y,ydata = retrieveItemAndDataFromIndex 1 in
                    let z,zdata = retrieveItemAndDataFromIndex 2 in
                    match (xdata,ydata,zdata) with
                        | (JTagData TDoAction da),(JTagData TShowFrame),_ ->

                            let hasMain = match (asActionType(asAction(listGet da 0))) with
                                | AStringPool strList -> (match (toStringList strList) with
                                    | ("MTASC_MAIN" :: _) -> true
                                    | _ -> false)
                                | _ -> false
                            in
                            if ((listLength da) > 0) && hasMain then
                                (
                                    let doActionWithMainFunc bList =
                                        listRemove aList 0;
                                        listRemove aList 1;
                                        listAdd bList y;
                                        bList
                                    in
                                    loop acc (listConcat (doActionWithMainFunc (newList [])) aList)
                                )
                            else
                                (
                                    let doActionFunc bList =
                                        listRemove aList 0;
                                        listRemove aList 1;
                                        listAdd bList y;
                                        listAdd bList x;
                                        bList
                                    in
                                    insert loop (doActionFunc (newList [])) acc aList
                                )

                        | (JTagData TShowFrame),_,_ ->

                            let showFrameFunc bList =
                                listAdd bList x;
                                listRemove aList 0;
                                bList
                            in
                            let showFrameList = showFrameFunc (newList []) in
                            insert loop showFrameList acc aList

                        | (JTagData TClip _),(JTagData TExports e),(JTagData TDoInitAction _) ->

                            let myExport = asExport (listGet e 0) in
                            let name = asString(getMField (JExport myExport) "exp_name") in
                            let cid = asInt(getMField (JExport myExport) "exp_id") in
                            let aList2 = replace_package name cid x y z in
                            if (listLength aList2) <> 0 then
                                listInsert 0 found_ids (JInt cid);
                            let clipFunc =
                                listRemove aList 0;
                                listRemove aList 1;
                                listRemove aList 2;
                                listRev aList2;
                                listConcat aList2 acc
                            in
                            loop clipFunc aList
                            
                        | (JTagData TDoInitAction dia),_,_ ->

                            let process mcname clname =
                                let doReverse argList =
                                    listRev argList;
                                    argList
                                in
                                let cpath =
                                    match (listLength (doReverse (stringSplit clname "."))) with
                                        | 0 -> assert false
                                        | _ ->

                                            (* this is very ugly... *)

                                            let doInitActionFunc =
                                                listRemove aList 0;
                                                let resList = ref [] in
                                                for i = 0 to listLength aList do
                                                    let curItem = asString (listGet tags i) in
                                                    resList := curItem :: !resList
                                                done;
                                                !resList
                                            in
                                            let firstItem = asString (listGet tags 0) in
                                            doInitActionFunc,firstItem
                                in
                                (try
                                    ignore(Class.getclass ctx.current cpath)
                                with
                                    _ ->
                                        if (not !use_components || (match cpath with ("mx" :: _, _) -> false | _ -> true)) then
                                            let errorStr = " which was not compiled :\nPlease force compilation of this class by adding it to the commandline." in
                                            prerr_endline ("Warning : The MovieClip " ^ mcname ^ " needs the class " ^ clname ^ errorStr));
                                if !found then
                                        let doStuffFunc =
                                            listInsert acc 0 x;
                                            acc
                                        in
                                        loop doStuffFunc aList
                                else begin
                                        listInsert regs 0 x;
                                        loop acc aList
                                end
                            in
                            ( process "" ""
                                (* this is very ugly... *)

(*
                                let convertToCamlType diaObj =
                                    let dia_actions = asActions (getMField diaObj "dia_actions") in
                                    let resList = ref [] in
                                    for i = 0 to listLength acts do
                                        let curAction = asAction (listGet acts i) in
                                        resList := !resList :: curItem;
                                    done;
                                    !ref
                                in
                                match (convertToCamlType dia) with
                                    | [
                                            APush [PString clname];
                                            AEval;
                                            APush [PString mcname;PInt _;PString "Object"];
                                            AEval;
                                            APush [PString "registerClass"];
                                            AObjCall;
                                            APop
                                    ] -> (* interface ?? *)
                                            process mcname clname
                                    | [
                                            AStringPool [clname;"Object";"registerClass"];
                                            APush [PStack 0];
                                            AEval;
                                            APush [PStack 0;PInt _;PStack 1];
                                            AEval;
                                            APush [PStack 2];
                                            AObjCall;
                                            APop;
                                    ] ->
                                            (* classe ?? *)
                                            process clname clname
                                    | _ ->
                                            loop (x :: acc) l
*)
                            );

                        | _,_,_ -> assert false
	in
        let t = loop (newList []) (newList []) in
        print_endline "call to a java primitive with the complete tag list";

generate_function_ref := generate_function ftrace;